home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / scsh / char-set.scm < prev    next >
Text File  |  1995-10-13  |  7KB  |  202 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; Character Sets package
  4. ;;; ported from MIT Scheme runtime
  5. ;;; by Brian D. Carlstrom
  6. ;;; Sleazy code.
  7.  
  8. (define char:newline (ascii->char 13))
  9. (define char:tab (ascii->char 9))
  10. (define char:linefeed (ascii->char 13))
  11. (define char:page (ascii->char 12))
  12. (define char:return (ascii->char 10))
  13. (define char:space (ascii->char 32))
  14.  
  15. (define (string-fill-range! str lower upper ch)
  16.   (do ((index lower (+ index 1)))
  17.     ((>= index upper) str)
  18.     (string-set! str index ch)))
  19.  
  20. (define (char-ascii? char)
  21.   (let ((maybe-ascii (char->ascii char)))
  22.     (if (and (< maybe-ascii 128)
  23.          (>= maybe-ascii 0))
  24.     maybe-ascii
  25.     #f)))
  26.  
  27. ;;;; Character Sets
  28.  
  29. (define (char-set? object)
  30.   (and (string? object)
  31.        (= (string-length object) 256)))
  32.  
  33. (define (char-set . chars)
  34.   (chars->char-set chars))
  35.  
  36. (define (chars->char-set chars)
  37.   (let ((char-set (make-string 256 (ascii->char 0))))
  38.     (for-each (lambda (char) 
  39.         (string-set! char-set (char->ascii char) (ascii->char 1)))
  40.           chars)
  41.     char-set))
  42.  
  43. (define (string->char-set str)
  44.   (let ((char-set (make-string 256 (ascii->char 0))))
  45.     (do ((i (- (string-length str) 1) (- i 1)))
  46.     ((< i 0) char-set)
  47.       (string-set! char-set (char->ascii (string-ref str i))
  48.            (ascii->char 1)))))
  49.  
  50. (define (ascii-range->char-set lower upper)
  51.   (let ((char-set (make-string 256 (ascii->char 0))))
  52.     (string-fill-range! char-set lower upper (ascii->char 1))
  53.     char-set))
  54.  
  55. (define (predicate->char-set predicate)
  56.   (let ((char-set (make-string 256)))
  57.     (let loop ((code 0))
  58.       (if (< code 256)
  59.       (begin (string-set! char-set code
  60.                  (if (predicate (ascii->char code)) 
  61.                      (ascii->char 1)
  62.                      (ascii->char 0)))
  63.          (loop (+ 1 code)))))
  64.     char-set))
  65.  
  66.  
  67. ;;; {string, char, char-set, char predicate} -> char-set
  68.  
  69. (define (->char-set x)
  70.   (cond ((char-set? x) x)
  71.     ((string? x) (string->char-set x))
  72.     ((char? x) (char-set x))
  73.     ((procedure? x) (predicate->char-set x))
  74.     (else (error "->char-set: Not a charset, string, char, or predicate."
  75.              x))))
  76.  
  77.  
  78. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  79.  
  80. (define (char-set-members char-set)
  81.   (define (loop code)
  82.     (cond ((>= code 256) '())
  83.       ((zero? (char->ascii (string-ref char-set code))) (loop (+ 1 code)))
  84.       (else (cons (ascii->char code) (loop (+ 1 code))))))
  85.   (loop 0))
  86.  
  87. ;;; De-releasing CHAR-SET-MEMBER?
  88. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  89. ;;; No other way to do it. MIT Scheme defines it (c-s-m? cset char); scsh 0.3
  90. ;;; defined it (c-s-m? char cset). MIT Scheme's arg order is not consistent 
  91. ;;; with the MEMBER? procedure or common math notation, but they were here
  92. ;;; first, so I didn't want to just silently invert their arg order -- could
  93. ;;; break code. I ended up just choosing a new proc name that consistent with
  94. ;;; its arg order -- (CHAR-SET-CONTAINS? cset char).
  95.  
  96. (define (char-set-contains? char-set char)
  97.   (let ((ascii (char-ascii? char)))
  98.     (and ascii (not (zero? (char->ascii (string-ref char-set ascii)))))))
  99.  
  100. ;;; This actually isn't exported. Just CYA.
  101. (define (char-set-member? . args)
  102.   (error "CHAR-SET-MEMBER? is no longer provided. Use CHAR-SET-CONTAINS? instead."))
  103.  
  104. (define (char-set-invert char-set)
  105.   (predicate->char-set
  106.    (lambda (char) (not (char-set-contains? char-set char)))))
  107.  
  108. (define (char-set-union char-set-1 char-set-2)
  109.   (predicate->char-set
  110.    (lambda (char)
  111.      (or (char-set-contains? char-set-1 char)
  112.      (char-set-contains? char-set-2 char)))))
  113.  
  114. (define (char-set-intersection char-set-1 char-set-2)
  115.   (predicate->char-set
  116.    (lambda (char)
  117.      (and (char-set-contains? char-set-1 char)
  118.       (char-set-contains? char-set-2 char)))))
  119.  
  120. (define (char-set-difference char-set-1 char-set-2)
  121.   (predicate->char-set
  122.    (lambda (char)
  123.      (and (char-set-contains? char-set-1 char)
  124.       (not (char-set-contains? char-set-2 char))))))
  125.  
  126. ;;;; System Character Sets
  127.  
  128. (define char-set:upper-case (ascii-range->char-set #x41 #x5B))
  129. (define char-set:lower-case (ascii-range->char-set #x61 #x7B))
  130. (define char-set:numeric (ascii-range->char-set #x30 #x3A))
  131. (define char-set:graphic (ascii-range->char-set #x20 #x7F))
  132. (define char-set:not-graphic (char-set-invert char-set:graphic))
  133. (define char-set:whitespace
  134.   (char-set char:newline char:tab char:linefeed 
  135.         char:page char:return char:space))
  136. (define char-set:not-whitespace (char-set-invert char-set:whitespace))
  137. (define char-set:alphabetic
  138.   (char-set-union char-set:upper-case char-set:lower-case))
  139. (define char-set:alphanumeric
  140.   (char-set-union char-set:alphabetic char-set:numeric))
  141. (define char-set:standard
  142.   (char-set-union char-set:graphic (char-set char:newline)))
  143.  
  144. (define (char-upper-case? char)
  145.   (char-set-contains? char-set:upper-case char))
  146.  
  147. (define (char-lower-case? char)
  148.   (char-set-contains? char-set:lower-case char))
  149.  
  150. (define (char-numeric? char)
  151.   (char-set-contains? char-set:numeric char))
  152.  
  153. (define (char-graphic? char)
  154.   (char-set-contains? char-set:graphic char))
  155.  
  156. (define (char-whitespace? char)
  157.   (char-set-contains? char-set:whitespace char))
  158.  
  159. (define (char-alphabetic? char)
  160.   (char-set-contains? char-set:alphabetic char))
  161.  
  162. (define (char-alphanumeric? char)
  163.   (char-set-contains? char-set:alphanumeric char))
  164.  
  165. (define (char-standard? char)
  166.   (char-set-contains? char-set:standard char))
  167.  
  168. ;;; Bullshit legalese
  169. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  170. ;$Header: /sw/scsh/scsh/scsh/char-set.scm,v 1.1.1.1 1995/10/14 03:33:40 bdc Exp $
  171.  
  172. ;Copyright (c) 1988 Massachusetts Institute of Technology
  173.  
  174. ;This material was developed by the Scheme project at the Massachusetts
  175. ;Institute of Technology, Department of Electrical Engineering and
  176. ;Computer Science.  Permission to copy this software, to redistribute
  177. ;it, and to use it for any purpose is granted, subject to the following
  178. ;restrictions and understandings.
  179.  
  180. ;1. Any copy made of this software must include this copyright notice
  181. ;in full.
  182.  
  183. ;2. Users of this software agree to make their best efforts (a) to
  184. ;return to the MIT Scheme project any improvements or extensions that
  185. ;they make, so that these may be included in future releases; and (b)
  186. ;to inform MIT of noteworthy uses of this software.
  187.  
  188. ;3. All materials developed as a consequence of the use of this
  189. ;software shall duly acknowledge such use, in accordance with the usual
  190. ;standards of acknowledging credit in academic research.
  191.  
  192. ;4. MIT has made no warrantee or representation that the operation of
  193. ;this software will be error-free, and MIT is under no obligation to
  194. ;provide any services, by way of maintenance, update, or otherwise.
  195.  
  196. ;5. In conjunction with products arising from the use of this material,
  197. ;there shall be no use of the name of the Massachusetts Institute of
  198. ;Technology nor of any adaptation thereof in any advertising,
  199. ;promotional, or sales literature without prior written consent from
  200. ;MIT in each case. 
  201.  
  202.